R Notebook

Airbender predictive text

Our modeling goal is to predict the speaker of each line of dialogue.

https://juliasilge.com/blog/last-airbender/

library(tidyverse)

Registered S3 methods overwritten by 'dbplyr':
  method         from
  print.tbl_lazy     
  print.tbl_sql      
── Attaching packages ──────────────────── tidyverse 1.3.0 ──
✓ ggplot2 3.3.2     ✓ purrr   0.3.4
✓ tibble  3.0.4     ✓ dplyr   1.0.2
✓ tidyr   1.1.2     ✓ stringr 1.4.0
✓ readr   1.4.0     ✓ forcats 0.5.0
── Conflicts ─────────────────────── tidyverse_conflicts() ──
x dplyr::filter() masks stats::filter()
x dplyr::lag()    masks stats::lag()

avatar_raw <- read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2020/2020-08-11/avatar.csv")

── Column specification ─────────────────────────────────────
cols(
  id = col_double(),
  book = col_character(),
  book_num = col_double(),
  chapter = col_character(),
  chapter_num = col_double(),
  character = col_character(),
  full_text = col_character(),
  character_words = col_character(),
  writer = col_character(),
  director = col_character(),
  imdb_rating = col_double()
)

avatar_raw %>%
  count(character, sort = TRUE)

Rows with Scene Description are not dialogue; the main character Aang speaks the most lines overall. How does this change through the three “books” of the show?

library(tidytext)

avatar_raw %>%
  filter(!is.na(character_words)) %>%
  mutate(
    book = fct_inorder(book),
    character = fct_lump_n(character, 10)
  ) %>%
  count(book, character) %>%
  mutate(character = reorder_within(character, n, book)) %>%
  ggplot(aes(n, character, fill = book)) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~book, scales = "free") +
  scale_y_reordered() +
  labs(y = NULL)

Let’s create a dataset for our modeling question, and look at a few example lines.

avatar <- avatar_raw %>%
  filter(!is.na(character_words)) %>%
  mutate(aang = if_else(character == "Aang", "Aang", "Other")) %>%
  select(aang, book, text = character_words)

avatar %>%
  filter(aang == "Aang") %>%
  sample_n(10) %>%
  pull(text)

 [1] "Sorry, ma'am."                                                      
 [2] "Katara, whoever's in there might help figure out this Avatar thing!"
 [3] "I'm gonna throw them,  a secret dance party!"                       
 [4] "Come on, Appa! The boat! There!"                                    
 [5] "I like jokes."                                                      
 [6] "Watch this, everybody!"                                             
 [7] "Sokka, go back!"                                                    
 [8] "So where am I, Roku? What is this place?"                           
 [9] "Appa's exhausted."                                                  
[10] "Where's Appa?"                                                      

What are the highest log odds words from Aang and other speakers?

library(tidytext)
library(tidylo)

avatar_lo <- avatar %>%
  unnest_tokens(word, text) %>%
  count(aang, word) %>%
  bind_log_odds(aang, word, n) %>%
  arrange(-log_odds_weighted)

avatar_lo %>%
  group_by(aang) %>%
  top_n(15) %>%
  ungroup() %>%
  mutate(word = reorder(word, log_odds_weighted)) %>%
  ggplot(aes(log_odds_weighted, word, fill = aang)) +
  geom_col(alpha = 0.8, show.legend = FALSE) +
  facet_wrap(~aang, scales = "free") +
  labs(y = NULL)

Selecting by log_odds_weighted

These words make sense, but the counts are probably too low to build a good model with. Instead, let’s try using text features like the number of punctuation characters, number of pronons, and so forth.

library(textfeatures)

tf <- textfeatures(
  avatar,
  sentiment = FALSE, word_dims = 0,
  normalize = FALSE, verbose = FALSE
)

tf %>%
  bind_cols(avatar) %>%
  group_by(aang) %>%
  summarise(across(starts_with("n_"), mean)) %>%
  pivot_longer(starts_with("n_"), names_to = "text_feature") %>%
  filter(value > 0.01) %>%
  mutate(text_feature = fct_reorder(text_feature, -value)) %>%
  ggplot(aes(aang, value, fill = aang)) +
  geom_col(position = "dodge", alpha = 0.8, show.legend = FALSE) +
  facet_wrap(~text_feature, scales = "free", ncol = 6) +
  scale_fill_avatar("AirNomads") +
  labs(x = NULL, y = "Mean text features per spoken line")

`summarise()` ungrouping output (override with `.groups` argument)
Error in scale_fill_avatar("AirNomads") : 
  could not find function "scale_fill_avatar"

See more about previous countings here: https://textfeatures.mikewk.com/reference/count_functions.html

Build a model

We can start by loading the tidymodels metapackage, and splitting our data into training and testing sets.

library(tidymodels)

set.seed(123)
avatar_split <- initial_split(avatar, strata = aang)
avatar_train <- training(avatar_split)
avatar_test <- testing(avatar_split)

let’s create cross-validation resamples of the training data, to evaluate our models.

set.seed(234)
avatar_folds <- vfold_cv(avatar_train, strata = aang)
avatar_folds

#  10-fold cross-validation using stratification 

let’s preprocess our data to get it ready for modeling.

avatar_prep <- prep(avatar_rec)
avatar_prep <- prep(avatar_rec)
avatar_prep

Data Recipe

Inputs:

Training data contained 7494 data points and no missing data.

Operations:

Down-sampling based on aang [trained]
Text feature extraction for text [trained]
Zero variance filter removed 

no non-missing arguments to max; returning -Inf

15 items [trained]
Centering and scaling for 12 items [trained]

juice(avatar_prep)

Let’s walk through the steps in this recipe.

First, we must tell the recipe() what our model is going to be (using a formula here) and what data we are using. Next, we downsample for our predictor, since there are many more lines spoken by characters other than Aang than by Aang. We create the text features using a step from the textrecipes package. Then we remove zero-variance variables, which includes variables like the text features about URLs and hashtags in this case. Finally, we center and scale the predictors because of the specific kind of model we want to try out.

We’re mostly going to use this recipe in a workflow() so we don’t need to stress too much about whether to prep() or not. Since we are going to compute variable importance, we will need to come back to juice(avatar_prep).

Let’s compare two different models, a random forest model and a support vector machine model. We start by creating the model specifications.

rf_spec <- rand_forest(trees = 1000) %>%
  set_engine("ranger") %>%
  set_mode("classification")

rf_spec

Random Forest Model Specification (classification)

Main Arguments:
  trees = 1000

Computational engine: ranger 

svm_spec <- svm_rbf(cost = 0.5) %>%
  set_engine("kernlab") %>%
  set_mode("classification")

svm_spec

Radial Basis Function Support Vector Machine Specification (classification)

Main Arguments:
  cost = 0.5

Computational engine: kernlab 

Next let’s start putting together a tidymodels workflow(), a helper object to help manage modeling pipelines with pieces that fit together like Lego blocks. Notice that there is no model yet: Model: None.

avatar_wf <- workflow() %>%
  add_recipe(avatar_rec)

avatar_wf

══ Workflow ═════════════════════════════════════════════════
Preprocessor: Recipe
Model: None

── Preprocessor ─────────────────────────────────────────────
4 Recipe Steps

● step_downsample()
● step_textfeature()
● step_zv()
● step_normalize()

Now we can add a model, and the fit to each of the resamples. First, we can fit the random forest model.

doParallel::registerDoParallel()

set.seed(1234)
rf_rs <- avatar_wf %>%
  add_model(rf_spec) %>%
  fit_resamples(
    resamples = avatar_folds,
    metrics = metric_set(roc_auc, accuracy, sens, spec),
    control = control_grid(save_pred = TRUE)
  )

Second, we can fit the support vector machine model.

set.seed(2345)
svm_rs <- avatar_wf %>%
  add_model(svm_spec) %>%
  fit_resamples(
    resamples = avatar_folds,
    metrics = metric_set(roc_auc, accuracy, sens, spec),
    control = control_grid(save_pred = TRUE)
  )

Attaching package: ‘kernlab’

The following object is masked from ‘package:scales’:

    alpha

The following object is masked from ‘package:purrr’:

    cross

The following object is masked from ‘package:ggplot2’:

    alpha

We have fit each of our candidate models to our resampled training set.

Evaluate model

collect_metrics(rf_rs)

conf_mat_resampled(rf_rs)

collect_metrics(svm_rs)

conf_mat_resampled(svm_rs)

Different, but not really better! The SVM model is better able to identify the positive cases but at the expense of the negative cases. Overall, we definitely see that this is a hard problem that we barely are able to have any predictive ability for.

Let’s say we are more interested in detecting Aang’s lines, even at the expense of the false positives.

svm_rs %>%
  collect_predictions() %>%
  group_by(id) %>%
  roc_curve(aang, .pred_Aang) %>%
  ggplot(aes(1 - specificity, sensitivity, color = id)) +
  geom_abline(lty = 2, color = "black", size = 1) +
  geom_path(show.legend = FALSE, alpha = 0.6, size = 0.5) +
  coord_equal()

This plot highlights how this model is barely doing better than guessing.

Keeping in mind the realities of our model performance, let’s talk about how to compute variable importance for a model like an SVM, which does not have information within it about variable importance like a linear model or a tree-based model. In this case, we can use a method like permutation of the variables.

These are the text features that are most important globally for whether a line was spoken by Aang or not.

Finally, we can return to the testing data to confirm that our performance is about the same.

avatar_final %>%
  collect_predictions() %>%
  conf_mat(aang, .pred_class)

          Truth
Prediction Aang Other
     Aang   261  1004
     Other  188  1045